(** Configfile.ml - Parse simple config files. *)

(** Thrown where there is a parse error *)
exception Parse_error of string

(** Thrown when a section doesn't exist *)
exception Missing_section of string

(** Thrown when an option doesn't exist *)
exception Missing_option of string

(** Thrown when an option has no value *)
exception Missing_value of string


(** An option specification *)
type option_spec = {
  opt_name	: string;	(** Option name *)
  opt_default	: string list;	(** Default value(s) *)
}

(** A section specification *)
type section_spec = {
  sec_name	: string;	(** Section name *)
  sec_opt_specs : option_spec list;
}


(** A section *)
type s = {
  s_name 	: string;
  s_entries	: (string * string) list;
}

(** A config file store *)
type t = {
  t_sec 	: s list;
  t_defaults	: section_spec list;
}


(* FIXME: The way this is called makes saving a config file O(n*m)
   where [n] is the number of sections in defaults and [m] is the
   number of sections in memory *)

let defaults_section sec defaults =
  try
    let s =
      List.find (fun s -> s.sec_name = sec) defaults
    in
    Some s
  with Not_found ->
    None


(* FIXME: The way this is called makes saving a config file O(n*m)
   where [n] is the number of options in the largest section, and
   [m] is the number of options in memory *)

let defaults_option s opt =
  try
    let o =
      List.find (fun o -> o.opt_name = opt) s.sec_opt_specs
    in
    Some o
  with Not_found ->
    None


(** You can create a config store just from the defaults *)

let from_defaults defaults =
  { t_defaults = defaults
  ; t_sec =
      List.map
	(fun s ->
	  { s_name = s.sec_name
	  ; s_entries =
	      let entries' =
		List.map
		  (fun o ->
		    List.map (fun e -> (o.opt_name, e)) o.opt_default)
		  s.sec_opt_specs
	      in
	      List.flatten entries'
	  })
	defaults
  }


(** Get a list of all the sections *)
let sections t =
  List.map
    (function a -> a.s_name)
    t.t_sec


(** Get a list of all the options and values in a given section *)
let options t sec =
  let rec find sec = function
    | [] -> raise (Missing_section sec)
    | hd :: tl when hd.s_name = sec -> hd.s_entries
    | hd :: tl -> find sec tl
  in
  find sec t.t_sec



(** Add an empty section. If the section already exists then nothing
    happens. *)

let add_section t sec =
  if List.mem sec (sections t) then
    t
  else
    let s = { s_name = sec; s_entries = [] } in
    {t with t_sec = s :: t.t_sec }


(** [add t section option value]
    Add a value to some option.
    @raise Missing_section
*)
let add t sec opt v =
  if List.mem sec (sections t) then
    { t with t_sec =
	List.map
	  (fun s ->
	    if s.s_name = sec then
	      { s with s_entries = (opt,v) :: s.s_entries }
	    else s)
	  t.t_sec
    }
  else
    raise (Missing_section sec)



(** [set_mult t section option values]

    Set multiple values for option. Note that this will remove all
    previous "shadow" values for the given option.

    @raise Missing_section
*)
let set_mult t sec opt v =
  let remove_all_assoc n l = List.filter (fun (a,_) -> a <> n) l in
  let add_all_assoc n l = List.map (fun a -> (n, a)) l in
  if List.mem sec (sections t) then
    {
      t with t_sec =
	List.map
	  (fun s ->
	    if s.s_name = sec then
	      let entries = s.s_entries in
	      let entries' =
		(add_all_assoc opt v) @
		  (remove_all_assoc opt entries) in
	      { s with s_entries = entries' }
	    else s)
	  t.t_sec
    }
  else
    raise (Missing_section sec)



(** Load config store from a file. *)
let load ch file defaults =
  let explode_assoc (n:string) (l:string list) = List.map (fun a -> (n, a)) l in
  let lexbuf = Configutil.from_channel ch file in
  let result : (string * (string * string) list) list =
    Parser.main Lexer.token lexbuf
  in
  let tbl =
    (* Add sections from file to a hash table. Though this changes the
       ordering, it will remove duplicates and make the rest of this
       function more efficient. *)
    let tbl : (string, (string *string) list) Hashtbl.t = Hashtbl.create 20 in
    List.iter
      (fun (sec, secdata) ->
	if Hashtbl.mem tbl sec then
	  let old = Hashtbl.find tbl sec in
	  (* Note that we add the newer bindings before the old ones! *)
	  Hashtbl.replace tbl sec (old @ secdata)
	else
	  Hashtbl.add tbl sec secdata)
      result;
    tbl
  in
  let () =
    (* Go through the defaults, and for any mission sections or
       options, add the data from the defaults *)
    List.iter
      (fun s ->
	if not (Hashtbl.mem tbl s.sec_name) then begin
	  Hashtbl.add tbl s.sec_name [];
	  List.iter
	    (fun o ->
	      (* Binding order shouldn't matter here...? *)
	      let old = Hashtbl.find tbl s.sec_name in
	      Hashtbl.replace tbl s.sec_name
		((explode_assoc o.opt_name o.opt_default) @ old))
	    s.sec_opt_specs
	end
	else begin
	  (* Go through any options, and for those that don't exist
	     in the table, add values *)
	  List.iter
	    (fun o ->
	      let old = Hashtbl.find tbl s.sec_name in
	      if List.mem_assoc o.opt_name old then
		()
	      else
		Hashtbl.replace tbl s.sec_name
		  ((explode_assoc o.opt_name o.opt_default) @ old))
	    s.sec_opt_specs
	end)
      defaults
  in
  (* Transform file format into in-memory format *)
  Hashtbl.fold
    (fun sec values t ->
      let newsec = { s_name = sec; s_entries = values } in
      { t with t_sec = newsec :: t.t_sec })
    tbl
    { t_defaults = defaults; t_sec = [] }



(** You can write out a store to a file *)

let save t ch ~save_all ~save_unknown =
  let is_special_char = function
    | 'A'..'Z' | 'a'..'z' | '0'..'9' -> false
    | '@' | ':' | '_' | '-' -> false
    | _ -> true
  in
  let quoted s =
    let l = String.length s in
    if l > 0 && (is_special_char s.[0] || is_special_char s.[l-1]) then
      "\"" ^ s ^ "\""
    else
      s
  in
  let save_option_if cond o v =
    if cond then begin
      Printf.fprintf ch "%s=%s\n" o (quoted v)
    end
  in
  let save_section_if cond s s' =
    if cond then begin
      Printf.fprintf ch "[%s]\n" s.s_name;
      match s' with
	| None ->
	    (* This section doesn't exist in defaults. We get here
	       only if [save_unknown] is true. Dump all options. *)
	    List.iter
	      (fun (o,v) -> Printf.fprintf ch "%s=%s\n" o (quoted v))
	      s.s_entries
	| Some s' ->
	    (* This section does exist in defaults, save options
	       depending on flags *)
	    List.iter
	      (fun (o,v) ->
		match defaults_option s' o with
		  | None -> save_option_if save_unknown o v
		  | Some o' ->
		      if List.mem v o'.opt_default then
			save_option_if save_all o v
		      else
			save_option_if true o v)
	      s.s_entries
    end
  in
  List.iter
    (fun s ->
      match defaults_section s.s_name t.t_defaults with
	| None ->
	    save_section_if save_unknown s None
	| Some s' ->
	    save_section_if true s (Some s'))
    t.t_sec


(** [get t section option]

    You can query some value. This returns the last binding for that
    option. This may happen if the config file or defaults have
    multiple values.

    @raise Missing_section
    @raise Missing_option
    @raise Missing_value
*)
let get t sec opt =
  let opts = options t sec in
  if List.mem_assoc opt opts then
    try
      List.assoc opt opts
    with Not_found ->
      raise (Missing_value opt)
  else
    raise (Missing_option opt)


(** As mentioned in the documentation for [get], an option may have
    multiple values. This returns all of them.

    @see get
    @raise Missing_section
*)
let getmult t sec opt =
  let rec loop accu opt = function
    | [] -> accu
    | (o,v) :: tl when o = opt -> loop (v :: accu) opt tl
    | hd :: tl -> loop accu opt tl
  in
  loop [] opt (options t sec)


let get_int t sec opt =
  int_of_string (get t sec opt)

let get_float t sec opt =
  float_of_string (get t sec opt)


(** Remove a section. If the section doesn't exist then nothing
    happens. *)

let del_section t sec =
  { t with t_sec =
      List.filter (fun s -> s.s_name <> sec)
	t.t_sec
  }


(** Utility functions for setting values of different types *)

let add_int t sec opt v =
  add t sec opt (string_of_int v)

let add_float t sec opt v =
  add t sec opt (string_of_float v)



(** Delete option's value from option store. This will remove the last
    binding of the option. Calling this multiple times will not raise
    an error.

    To remove {b all} values, call setmult with an empty list.
*)
let del t sec opt =
  { t with t_sec =
      List.map
	(fun s ->
	  if s.s_name = sec then
	    { s with s_entries =
		List.remove_assoc opt s.s_entries }
	  else s)
	t.t_sec
  }
